home *** CD-ROM | disk | FTP | other *** search
/ World of Education / World of Education.iso / world_s / sp12src.zip / WORDS.PAS < prev   
Pascal/Delphi Source File  |  1991-03-28  |  17KB  |  501 lines
  1. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V+,X+}
  2. {$M 6144,8192,655360}
  3. Program Words;
  4. { WORDS - A word extracter program.  Copyright 1990,91 by Edwin T. Floyd. }
  5. Uses Dos, Crt, Token, PairHeap;
  6.  
  7. Const
  8.   WordChar = ['a'..'z','A'..'Z']; { Default WordSet }
  9.   DefaultOutput = '';             { Default output filename (''=stdout) }
  10.   BufSize = 4096;                 { I/O buffer size }
  11.  
  12. Type
  13.   SetOpType = (Union, Intersection, Complement);
  14.   SetOfChar = Set Of Char;
  15.   SortEntryType = Object(HeapEntry)
  16.   { Data structure used for sorting }
  17.     Token : Word;
  18.   End;
  19.   SortHeapType = Object(Heap)
  20.   { PairHeap compare function override }
  21.     Function Less(Var x, y : HeapEntry) : Boolean; Virtual;
  22.   End;
  23.   FileEntryPtr = ^FileEntry;
  24.   FileEntry = Record
  25.   { Input file name list entry }
  26.     NextFile : FileEntryPtr;
  27.     FileName : PathStr;
  28.   End;
  29.  
  30. Const
  31.   FileList : FileEntryPtr = Nil;       { File name list (head) }
  32.   LastFile : FileEntryPtr = Nil;       { File name list (tail) }
  33.   HashTab : PToken = Nil;              { Hash table pointer }
  34.   TestTab : PToken = Nil;              { Test hash table pointer }
  35.   WordCount : LongInt = 0;             { Total number of words examined }
  36.   ReturnCode : Word = 0;               { Return code for Halt }
  37.   WordSet : SetOfChar = WordChar;      { Words are made of these }
  38.   SetOp : SetOpType = Union;           { Set operation }
  39.   Alphabetize : Boolean = False;       { If true, sort output words }
  40.   LowerCase : Boolean = False;         { If true, case is significant }
  41.   HighOrder : Boolean = False;         { If true, clear high-order bits }
  42.   SuppressOutput : Boolean = False;    { If true, do not write output file }
  43.   OutOfMemory : Boolean = False;       { Set true by HandleHeapError }
  44.   Aborted : Boolean = False;           { True if operator aborted }
  45.   OutName : PathStr = DefaultOutput;   { Output file name }
  46.  
  47. Var
  48.   OldMem : LongInt;                    { Original value of MemAvail }
  49.   SortHeap : SortHeapType;             { Sorter object }
  50.   TextFile : File;                     { Input/Output file }
  51.   TextBuf : Array[1..BufSize] Of Char; { I/O buffer for TextFile }
  52.  
  53. {$S+}
  54.  
  55. Function ProcessParameter(s : String) : Boolean; Forward;
  56.  
  57. Function ParseParamString(s : String) : Boolean;
  58. { Extract parameters from a string and process them; return True if all OK. }
  59. Var
  60.   i, j : Word;
  61.   ParamsOk : Boolean;
  62. Begin
  63.   ParamsOk := True;
  64.   While (s <> '') And (s[Length(s)] = ' ') Do Dec(s[0]);
  65.   While s <> '' Do Begin
  66.     i := 1;
  67.     While (i <= Length(s)) And (s[i] = ' ') Do Inc(i);
  68.     j := Succ(i);
  69.     While (j <= Length(s)) And (s[j] <> ' ') Do Inc(j);
  70.     If Not ProcessParameter(Copy(s, i, j - i)) Then ParamsOk := False;
  71.     Delete(s, 1, Pred(j));
  72.   End;
  73.   ParseParamString := ParamsOk;
  74. End;
  75.  
  76. Function ProcessParameter(s : String) : Boolean;
  77. { Process command line parameter or file name; return True if OK. }
  78. Var
  79.   ThisFile : FileEntryPtr;
  80.   IncludeFile : Text;
  81.   ParamOk : Boolean;
  82.   i, j : Word;
  83.   IoRes : Integer;
  84.  
  85.   Procedure GetFiles(Var s : String);
  86.   Var
  87.     Path : PathStr;
  88.     Dir : DirStr;
  89.     Name : NameStr;
  90.     Ext : ExtStr;
  91.     Search : SearchRec;
  92.   Begin
  93.     Path := FExpand(s);
  94.     FSplit(Path, Dir, Name, Ext);
  95.     FindFirst(Path, Archive, Search);
  96.     If DosError <> 0 Then Begin
  97.       WriteLn('No files match ', s);
  98.       ParamOk := False;
  99.     End;
  100.     While DosError = 0 Do Begin
  101.       Path := Dir + Search.Name;
  102.       ThisFile := FileList;
  103.       While (ThisFile <> Nil) And (ThisFile^.FileName <> Path) Do
  104.         ThisFile := ThisFile^.NextFile;
  105.       If ThisFile = Nil Then Begin
  106.         New(ThisFile);
  107.         If ThisFile <> Nil Then Begin
  108.           With ThisFile^ Do Begin
  109.             NextFile := Nil;
  110.             FileName := Path;
  111.           End;
  112.           If LastFile = Nil Then FileList := ThisFile
  113.           Else LastFile^.NextFile := ThisFile;
  114.           LastFile := ThisFile;
  115.         End;
  116.       End Else WriteLn('Already in list: ', Path);
  117.       FindNext(Search);
  118.     End;
  119.   End;
  120.  
  121. Begin
  122.   ParamOk := True;
  123.   If (s[1] = '-') Or (s[1] = '/') Then Case UpCase(s[2]) Of
  124.     'U' : SetOp := Union;
  125.     'I' : SetOp := Intersection;
  126.     'C' : SetOp := Complement;
  127.     'A' : If s[3] = '-' Then Alphabetize := False Else Alphabetize := True;
  128.     'L' : If s[3] = '-' Then LowerCase := False Else LowerCase := True;
  129.     'H' : If s[3] = '-' Then HighOrder := False Else HighOrder := True;
  130.     'O' : Begin
  131.       Delete(s, 1, 2);
  132.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  133.       If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
  134.         SuppressOutput := True;
  135.         OutName := '-';
  136.       End Else Begin
  137.         SuppressOutput := False;
  138.         If s = '' Then OutName := s Else OutName := FExpand(s);
  139.       End;
  140.     End;
  141.     'W' : Begin
  142.       Delete(s, 1, 2);
  143.       Case s[1] Of
  144.         '+' : ;
  145.         '-' : WordSet := [];
  146.         Else Begin
  147.           WriteLn('WordSet (-W) option must be followed by + or -.');
  148.           ParamOk := False;
  149.         End;
  150.       End;
  151.       Delete(s, 1, 1);
  152.       For i := 1 To Length(s) Do
  153.         WordSet := WordSet + [s[i]];
  154.     End;
  155.     Else Begin
  156.       WriteLn('Unrecognized option: ', s);
  157.       ParamOk := False;
  158.     End;
  159.   End Else If s[1] = '@' Then Begin
  160.     Delete(s, 1, 1);
  161.     For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  162.     Assign(IncludeFile, s);
  163.     Reset(IncludeFile);
  164.     IoRes := IoResult;
  165.     If IoRes = 0 Then Begin
  166.       WriteLn('Processing include file ', s);
  167.       Repeat
  168.         ReadLn(IncludeFile, s);
  169.         IoRes := IoResult;
  170.         If IoRes = 0 Then If Not ParseParamString(s) Then ParamOk := False;
  171.       Until Eof(IncludeFile) Or (IoRes <> 0);
  172.       If IoRes <> 0 Then Begin
  173.         WriteLn('Error ', IoRes, ' reading include file');
  174.         ParamOk := False;
  175.       End;
  176.       Close(IncludeFile);
  177.       IoRes := IoResult;
  178.     End Else Begin
  179.       WriteLn('Error ', IoRes, ' opening include file ', s);
  180.       ParamOk := False;
  181.     End;
  182.   End Else GetFiles(s);
  183.   ProcessParameter := ParamOk;
  184. End;
  185.  
  186. Procedure ParseParams;
  187. { Interpret environment and command line parameters; display Help info. }
  188. Var
  189.   i, j : Word;
  190.   ParamsOk : Boolean;
  191.   Ch : Char;
  192.   s : String;
  193. Begin
  194.   WriteLn('WORDS v1.2 - A word extractor program.  Copyright (c) 1990,91 by Edwin T. Floyd.');
  195.   ParamsOk := True;
  196.   If Not ParseParamString(GetEnv('WORDS')) Then Begin
  197.     WriteLn('Error found in SET WORDS=.. environment string');
  198.     ParamsOk := False;
  199.   End;
  200.   For i := 1 To ParamCount Do Begin
  201.     FillChar(s[1], 255, ' ');
  202.     s := ParamStr(i);
  203.     If Not ProcessParameter(s) Then ParamsOk := False;
  204.   End;
  205.   If Not ParamsOk Then Begin
  206.     WriteLn('At least one parameter was in error.  Run WORDS with no parameters');
  207.     WriteLn('to see documentation.');
  208.     Halt(1);
  209.   End Else If FileList = Nil Then Begin
  210.     WriteLn;
  211.     WriteLn('  WORDS filenames.. [-U/-I/-C] [-A] [-L] [-H] [-W[+/-]abc..] [-Oname] [@name]' );
  212.     WriteLn;
  213.     WriteLn('All command line parameters are separated by spaces.  Input text filenames');
  214.     WriteLn('and options may be intermixed; options are distinguished by a leading hyphen:');
  215.     WriteLn;
  216.     WriteLn('  -U, -I or -C specifies the set operation to be performed on the extracted');
  217.     WriteLn('  words from the files.  The operations are:');
  218.     WriteLn('    -U Union:        Keep all unique words from any input file (default);');
  219.     WriteLn('    -I Intersection: Keep unique words common to all files;');
  220.     WriteLn('    -C Complement:   Keep unique words from second and subsequent files only');
  221.     WriteLn('                     if they are not contained in the first file.');
  222.     WriteLn('  -A[-] Sort output words alphabetically (default off).');
  223.     WriteLn('  -H[-] Clear high-order bits on input file (i.e. WordStar, default off).');
  224.     WriteLn('  -L[-] Lower case is significant (default off).');
  225.     WriteLn('  -W-abc.. Replace the word character set with the indicated characters');
  226.     WriteLn('     (default is all alphabetic characters, upper and lower case).');
  227.     WriteLn('  -W+abc.. Add additional characters to the word character set.');
  228.     WriteLn('  -O[name] Name the output file (default is name omitted => stdout).');
  229.     WriteLn('  -O- Suppress output (counts are still displayed on screen).');
  230.     WriteLn;
  231.     WriteLn('The "@" prefixes the name of an ASCII include file which may contain');
  232.     Write('filenames, options, and nested include files, in any order.    ');
  233.     Ch := ReadKey;
  234.     WriteLn;
  235.     WriteLn;
  236.     WriteLn('You may use the DOS "SET" command to specify default parameters.  Examples:');
  237.     WriteLn;
  238.     WriteLn('  SET WORDS=-U -A+ -L+ -Owords.out -W-ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  239.     WriteLn('  SET WORDS=@defaults.wrd -O');
  240.     WriteLn;
  241.     WriteLn('Command line parameters override "SET" parameters.  WORDS examples:');
  242.     WriteLn;
  243.     WriteLn('  WORDS oldwords.lst document.txt -W+-'' -C -Onewwords.lst');
  244.     WriteLn('  WORDS @filename.lst -I -Oallwords.txt');
  245.     WriteLn('  WORDS file1.txt -A+ -U -L- -O | nextprog');
  246.     WriteLn;
  247.     WriteLn('WORDS was written by:');
  248.     WriteLn;
  249.     WriteLn('  Edwin T. Floyd         [76067,747]  (CompuServe)');
  250.     WriteLn('  #9 Adams Park Court    404/576-3305 (work)');
  251.     WriteLn('  Columbus, GA 31909     404/322-0076 (home)');
  252.     Halt(0);
  253.   End Else Begin
  254.     Case SetOp Of
  255.       Union : s := '-U';
  256.       Intersection : s := '-I';
  257.       Complement : s := '-C';
  258.     End;
  259.     If Alphabetize Then ch := '+' Else ch := '-';
  260.     s := s + ' -A' + ch;
  261.     If LowerCase Then ch := '+' Else ch := '-';
  262.     s := s + ' -L' + ch;
  263.     If HighOrder Then ch := '+' Else ch := '-';
  264.     s := s + ' -H' + ch;
  265.     OldMem := MemAvail;
  266.     WriteLn('Options: ', s, ' -O', OutName, ', ',
  267.       OldMem Shr 10, 'k free.');
  268.     WriteLn('Press <Esc> to stop.');
  269.   End;
  270. End;
  271.  
  272. {$S-}
  273.  
  274. Function SortHeapType.Less(Var x, y : HeapEntry) : Boolean;
  275. { Sort compare function override }
  276. Var
  277.   xx : SortEntryType Absolute x;
  278.   yy : SortEntryType Absolute y;
  279. Begin
  280.   Less := HashTab^.TokenAddress(xx.Token)^ < HashTab^.TokenAddress(yy.Token)^;
  281. End;
  282.  
  283. Function ParseInputBlock(Len : Word) : Word;
  284. { Insert words from input block into hash table }
  285. Var
  286.   Words : Word;
  287.   t : TokenString;
  288.   i, Toss : Word;
  289. Begin
  290.   i := 1;
  291.   Words := 0;
  292.   While i <= Len Do Begin
  293.     t := '';
  294.     While (i <= Len) And Not (TextBuf[i] In WordSet) Do Inc(i);
  295.     If i <= Len Then Begin
  296.       While (i <= Len) And (Length(t) < TokenStringSize)
  297.       And (TextBuf[i] In WordSet) Do Begin
  298.         Inc(t[0]);
  299.         If LowerCase Then t[Ord(t[0])] := TextBuf[i]
  300.         Else t[Ord(t[0])] := UpCase(TextBuf[i]);
  301.         Inc(i);
  302.       End;
  303.       Inc(Words);
  304.       Case SetOp Of
  305.         Union : Toss := HashTab^.TokenInsertText(t);
  306.         Intersection : If (TestTab <> Nil) And (TestTab^.TextToken(t) <> 0) Then
  307.           Toss := HashTab^.TokenInsertText(t);
  308.         Complement : If (TestTab <> Nil) And (TestTab^.TextToken(t) = 0) Then
  309.           Toss := HashTab^.TokenInsertText(t);
  310.       End;
  311.     End;
  312.   End;
  313.   ParseInputBlock := Words;
  314. End;
  315.  
  316. Procedure ProcessNextFile;
  317. { Open and process the next input file pointed to by FileList. }
  318. Var
  319.   ThisFile : FileEntryPtr;
  320.   TempTab : PToken;
  321.   FileWords : LongInt;
  322.   i, MaxLen, Len : Word;
  323.   FileResult : Integer;
  324. Begin
  325.   ThisFile := FileList;
  326.   With ThisFile^ Do Begin
  327.     Write(FileName, ': ');
  328.     Assign(TextFile, FileName);
  329.     Reset(TextFile, 1);
  330.     FileResult := IoResult;
  331.     If FileResult = 0 Then Begin
  332.       If HashTab = Nil Then New(HashTab, Init);
  333.       Len := 0;
  334.       FileWords := 0;
  335.       Repeat
  336.         BlockRead(TextFile, TextBuf[Succ(Len)], BufSize-Len, i);
  337.         FileResult := IoResult;
  338.         If FileResult = 0 Then Begin
  339.           MaxLen := Len + i;
  340.           If HighOrder Then For i := Succ(Len) To MaxLen Do
  341.             TextBuf[i] := Chr(Ord(TextBuf[i]) And $7F);
  342.           Len := MaxLen;
  343.           If Not Eof(TextFile) Then Begin
  344.             While (Len > 0) And (TextBuf[Len] In WordSet) Do Dec(Len);
  345.             If (Len = 0) Then Len := MaxLen;
  346.           End;
  347.           FileWords := FileWords + ParseInputBlock(Len);
  348.           MaxLen := MaxLen - Len;
  349.           If MaxLen > 0 Then
  350.             Move(TextBuf[Succ(Len)], TextBuf[1], MaxLen);
  351.           Len := MaxLen;
  352.           Write(^M, FileName, ': ', FileWords, ' words, ',
  353.             HashTab^.TokMaxToken, ' kept, ', (OldMem-MemAvail) Shr 10, 'k');
  354.           While KeyPressed Do If ReadKey = ^[ Then Aborted := True;
  355.         End;
  356.       Until Eof(TextFile) Or (FileResult <> 0) Or OutOfMemory Or Aborted;
  357.       Close(TextFile);
  358.       WriteLn(^M, FileName, ': ', FileWords, ' words, ',
  359.         HashTab^.TokMaxToken, ' kept, ', (OldMem-MemAvail) Shr 10, 'k');
  360.       WordCount := WordCount + FileWords;
  361.     End Else WriteLn('Unable to open input file ', FileName);
  362.     If FileResult <> 0 Then Begin
  363.       WriteLn('Error ', FileResult);
  364.       Inc(ReturnCode);
  365.     End;
  366.     FileList := NextFile;
  367.     If SetOp = Intersection Then Begin
  368.       TempTab := TestTab;
  369.       TestTab := HashTab;
  370.       HashTab := TempTab;
  371.       If HashTab <> Nil Then Begin
  372.         Dispose(HashTab, Done);
  373.         HashTab := Nil;
  374.       End;
  375.     End;
  376.   End;
  377.   Dispose(ThisFile);
  378. End;
  379.  
  380. Procedure ProcessFirstFile;
  381. { Process the first input file. }
  382. Var
  383.   TempTab : PToken;
  384.   Op : SetOpType;
  385. Begin
  386.   Op := SetOp;
  387.   SetOp := Union;
  388.   ProcessNextFile;
  389.   SetOp := Op;
  390.   If SetOp In [Intersection, Complement] Then Begin
  391.     TempTab := TestTab;
  392.     TestTab := HashTab;
  393.     HashTab := TempTab;
  394.   End;
  395. End;
  396.  
  397. Procedure SortWords;
  398. { Write words to output file, optionally sorted. }
  399. Var
  400.   SortEntry : ^SortEntryType;
  401.   FileResult : Integer;
  402.   i : Word;
  403.   OutFile : Text;
  404. Begin
  405.   If SuppressOutput Then WriteLn('Output suppressed') Else Begin
  406.     Assign(OutFile, OutName);
  407.     SetTextBuf(OutFile, TextBuf);
  408.     ReWrite(OutFile);
  409.     FileResult := IoResult;
  410.     If FileResult = 0 Then Begin
  411.       If Alphabetize Then With SortHeap Do Begin
  412.         Init;
  413.         For i := 1 To HashTab^.TokMaxToken Do Begin
  414.           New(SortEntry);
  415.           If SortEntry <> Nil Then Begin
  416.             SortEntry^.Token := i;
  417.             Insert(SortEntry^);
  418.           End;
  419.         End;
  420.         If OutOfMemory Then Begin
  421.           WriteLn('Sort suppressed due to insufficient memory');
  422.           Alphabetize := False;
  423.           Inc(ReturnCode);
  424.         End;
  425.       End;
  426.       If Alphabetize Then With SortHeap Do Begin
  427.         Write('Sorting and writing ', EntryCount, ' words to ');
  428.         If OutName = '' Then Write('<stdout>') Else Write(OutName);
  429.         WriteLn(', ', (OldMem-MemAvail) Shr 10, 'k');
  430.         For i := 1 To EntryCount Do Begin
  431.           SortEntry := DeleteLowEntry;
  432.           If FileResult = 0 Then Begin
  433.             WriteLn(OutFile, HashTab^.TokenAddress(SortEntry^.Token)^);
  434.             FileResult := IoResult;
  435.           End;
  436.         End;
  437.       End Else Begin
  438.         Write('Writing ', HashTab^.TokMaxToken, ' words to ');
  439.         If OutName = '' Then WriteLn('<stdout>') Else WriteLn(OutName);
  440.         For i := 1 To HashTab^.TokMaxToken Do If FileResult = 0 Then Begin
  441.           WriteLn(OutFile, HashTab^.TokenAddress(i)^);
  442.           FileResult := IoResult
  443.         End;
  444.       End;
  445.       If FileResult <> 0 Then Begin
  446.         WriteLn('Error ', FileResult, ' writing file ', OutName);
  447.         Inc(ReturnCode);
  448.       End;
  449.       Close(OutFile);
  450.       FileResult := IoResult;
  451.       If FileResult <> 0 Then Begin
  452.         WriteLn('Error ', FileResult, ' closing file ', OutName);
  453.         Inc(ReturnCode);
  454.       End;
  455.     End Else WriteLn('Error ', FileResult, ' opening file ', OutName);
  456.   End;
  457. End;
  458.  
  459. {$F+}
  460. Function HandleHeapError(Size : Word) : Integer;
  461. Begin
  462.   If Size > 0 Then Begin
  463.     HandleHeapError := 1;
  464.     OutOfMemory := True;
  465.   End;
  466. End;
  467. {$F-}
  468.  
  469. Begin
  470.   FileMode := $40;
  471.   HeapError := @HandleHeapError;
  472.   OldMem := MemAvail;
  473.   ParseParams;
  474.   ProcessFirstFile;
  475.   While (FileList <> Nil) And Not (OutOfMemory Or Aborted) Do ProcessNextFile;
  476.   If OutOfMemory Then Begin
  477.     WriteLn('Input file processing terminated due to insufficient memory');
  478.     WriteLn('Words collected so far will be written to output file');
  479.     Inc(ReturnCode);
  480.   End;
  481.   If Aborted Then Begin
  482.     WriteLn('File processing aborted by operator');
  483.     SuppressOutput := True;
  484.     Inc(ReturnCode);
  485.   End;
  486.   If SetOp = Intersection Then Begin
  487.     HashTab := TestTab;
  488.     TestTab := Nil;
  489.   End Else If Alphabetize And Not SuppressOutput Then Begin
  490.     WriteLn('Maximizing free memory for sort');
  491.     If TestTab <> Nil Then Dispose(TestTab, Done);
  492.     TestTab := Nil;
  493.   End;
  494.   WriteLn('Final Counts: ', WordCount, ' words examined, ',
  495.     HashTab^.TokMaxToken, ' kept, ', (OldMem-MemAvail) Shr 10, 'k in use');
  496.   OutOfMemory := False;
  497.   SortWords;
  498.   WriteLn('Done!');
  499.   Halt(ReturnCode);
  500. End.
  501.